home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xprolog.arc / listing < prev    next >
Encoding:
Text File  |  1987-10-12  |  2.6 KB  |  116 lines
  1. %
  2.  
  3. %    listing predicate
  4.  
  5. %
  6.  
  7. %    for Xprolog 2.0
  8.  
  9. %    by Andreas Toenne
  10.  
  11.  
  12.  
  13. % listing :-
  14.  
  15. %    all known and not hidden procedures are written to the output
  16.  
  17. %    stream. The output of listing can be reread.
  18.  
  19. % listing(name) :-
  20.  
  21. %    all known and not hidden procedures with the named head are
  22.  
  23. %    written as in listing.
  24.  
  25. % listing(ListOfNames) :-
  26.  
  27. %    applies listing(name) to all members of the list.
  28.  
  29.  
  30.  
  31. listing :-
  32.  
  33.     next_functor(Name, Arity),
  34.  
  35.     functor(Head, Name, Arity),        % construct clause head
  36.  
  37.     clause(Head, Body),            % find matching clause
  38.  
  39.     check_for_new_procedure(Name, Arity),    % nl if new procedure
  40.  
  41.     nl,
  42.  
  43.     write_clause(Head, Body),        % output the clause
  44.  
  45.     fail.                    % search for next solution
  46.  
  47. listing :- nl.
  48.  
  49.  
  50.  
  51. listing(X) :- var(X), !.            % don't list variables
  52.  
  53. listing([]) :- !.                % stop at empty list
  54.  
  55. listing([Name|Names]) :-
  56.  
  57.     !,
  58.  
  59.     listing(Name),
  60.  
  61.     listing(Names).
  62.  
  63. listing(Name) :-
  64.  
  65.     next_functor(Name, Arity),
  66.  
  67.     functor(Head, Name, Arity),
  68.  
  69.     clause(Head, Body),
  70.  
  71.     check_for_new_procedure(Name, Arity),
  72.  
  73.     nl,
  74.  
  75.     write_clause(Head, Body),
  76.  
  77.     fail.
  78.  
  79. listing(_) :- nl.
  80.  
  81.  
  82.  
  83. next_functor(Name, Arity) :- $functor(Name, Arity, Help).
  84.  
  85.  
  86.  
  87. check_for_new_procedure(Name, Arity) :-        % no changes
  88.  
  89.     lastlisted(Name, Arity),
  90.  
  91.     !.
  92.  
  93. check_for_new_procedure(Name, Arity) :-        % new procedure
  94.  
  95.     retract(lastlisted(_,_)),
  96.  
  97.     assert(lastlisted(Name, Arity)),
  98.  
  99.     nl.
  100.  
  101.     
  102.  
  103. write_clause(Head, true) :-
  104.  
  105.     writeq(Head),
  106.  
  107.     put(['.']),
  108.  
  109.     !.
  110.  
  111. write_clause(Head, Body) :-
  112.  
  113.     writeq(Head),
  114.  
  115.     write(' :- '),
  116.  
  117.     write_body(Body, 8, start),
  118.  
  119.     put(['.']),
  120.  
  121.     !.
  122.  
  123.     
  124.  
  125. write_body(X, _, _) :-                % Xprolog has no variable terms
  126.  
  127.     var(X),
  128.  
  129.     nl,
  130.  
  131.     !,
  132.  
  133.     write('***** variable goal is bad *****').
  134.  
  135. write_body((A,B), Tab, _) :-
  136.  
  137.     !,
  138.  
  139.     write_body(A, Tab, comma),
  140.  
  141.     put([',']),
  142.  
  143.     write_body(B, Tab, comma).
  144.  
  145. write_body((A;B), Tab, FromWhere) :-
  146.  
  147.     (
  148.  
  149.         FromWhere = start
  150.  
  151.         ;
  152.  
  153.         FromWhere = semicolon
  154.  
  155.     ),
  156.  
  157.     !,
  158.  
  159.     write_body(A, Tab, semicolon),
  160.  
  161.     nl,
  162.  
  163.     tab(Tab),
  164.  
  165.     put([';']),
  166.  
  167.     write_body(B, Tab, semicolon).
  168.  
  169. write_body((A;B), Tab, _) :-
  170.  
  171.     !,
  172.  
  173.     nl,
  174.  
  175.     tab(Tab),
  176.  
  177.     put(['(']),
  178.  
  179.     NewTab is Tab + 8,
  180.  
  181.     write_body(A, NewTab, semicolon),
  182.  
  183.     nl,
  184.  
  185.     tab(NewTab),
  186.  
  187.     put([';']),
  188.  
  189.     write_body(B, NewTab, semicolon),
  190.  
  191.     nl,
  192.  
  193.     tab(Tab),
  194.  
  195.     put([')']).
  196.  
  197. write_body(X, _, start) :-            % simple body
  198.  
  199.     !,
  200.  
  201.     writeq(X).
  202.  
  203. write_body(X, Tab, _) :-
  204.  
  205.     !,
  206.  
  207.     nl,
  208.  
  209.     tab(Tab),
  210.  
  211.     writeq(X).
  212.  
  213.  
  214.  
  215. lastlisted(foo, foo).                % for output formatting
  216.  
  217.  
  218.  
  219. % hide all new procedures
  220.  
  221.  
  222.  
  223. :- hide([listing, listing(_), next_functor(_,_), check_for_new_procedure(_,_),
  224.  
  225.      write_clause(_,_), write_body(_,_,_), lastlisted(_,_)]).
  226.  
  227.  
  228.  
  229.  
  230.  
  231.